home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ktencode / quickbas.bas < prev    next >
BASIC Source File  |  1995-05-09  |  6KB  |  257 lines
  1. 'This function has been modified to work in QuickBASIC.  This function
  2. 'was originally designed in VISUAL BASIC for WINDOWS 3.0 and was modified
  3. 'for use in QuickBASIC.  There were a few changes but everything works
  4. 'as described in the READTHIS.TXT file.
  5.  
  6. 'This is just a simple DEMO program to try the function.  Have fun!
  7. 'Programmed by Karl D Albreckt  (KARL25@AOL.COM)
  8. 'Please read the READTHIS.TXT file!
  9. 'Thank you
  10.  
  11.  
  12. DECLARE FUNCTION KTEncrypt$ (password$, strng$, Flag%, Errors$)
  13. Msg$ = "Hello, this is a test string to scramble."
  14.  
  15. CommandLoop:
  16.  
  17. CLS
  18. PRINT Msg$
  19. PRINT : PRINT : PRINT : PRINT : PRINT : PRINT
  20. PRINT STRING$(80, "-");
  21. LINE INPUT "PASSWORD:"; password$
  22. PRINT "0 - Encode  or  1 - Decode"
  23. OK = 0
  24. DO WHILE OK = 0
  25.   a$ = INKEY$
  26.   IF a$ = "1" OR a$ = "0" THEN OK = 1
  27. LOOP
  28. which% = VAL(a$)
  29.  
  30. Msg$ = KTEncrypt$(password$, Msg$, which%, Errors$)
  31. IF Errors$ <> "" THEN
  32.   BEEP
  33.  
  34.   PRINT : PRINT : PRINT "            " + Errors$
  35.   PRINT : PRINT " Press any key"
  36.   a$ = INPUT$(1)
  37. END IF
  38.  
  39. GOTO CommandLoop
  40.  
  41. 'Programmed by Karl Albrecht (KARL25@AOL.COM)
  42. Function KTEncrypt$ (password$, original$, Flag%, Errors$)
  43.   
  44.   'Dimension the Adjust array
  45.   ReDim Adjust(4)
  46.   
  47.   'Set error capture routine
  48.   On Local Error GoTo ErrorHandler
  49.  
  50.   'Preserve original string and work on strng$
  51.   strng$ = original$
  52.  
  53.   
  54.   
  55.   'Check for errors (Errorcodes are custom)
  56.   'Is there Password??
  57.   If Len(password$) = 0 Then Error 100
  58.   
  59.   'Is there a strng$ to work with?
  60.   If Len(strng$) = 0 Then Error 110
  61.  
  62.   'Check to see if it is an encoded file
  63.   If Right$(strng$, 5) = String$(5, 255) Then
  64.     'if encoding warn!
  65.     If Flag% = 0 Then Error 120
  66.   Else
  67.     'If decoding warn
  68.     If Flag% <> 0 Then Error 130
  69.   End If
  70.   
  71.  
  72.   
  73.   'Create a four part encryption code based on password
  74.   'First Adjust code based on length of password
  75.   Adjust(1) = Len(password$)
  76.   
  77.   'If first character ascii code even make adjust negative
  78.   If Asc(Left$(password$, 1)) / 2 = Int(Asc(Left$(password$, 1)) / 2) Then
  79.     Adjust(1) = Adjust(1) * -1
  80.   End If
  81.  
  82.   'Second Adjust code based on first and last character ascii codes
  83.   Adjust(2) = Asc(Left$(password$, 1)) - Asc(Right$(password$, 1))
  84.  
  85.   'Third code based on average of all ascii codes
  86.   TotalAscii = 0
  87.   For Looper = 1 To Len(password$)
  88.     TotalAscii = TotalAscii + Asc(Mid$(password$, Looper, 1))
  89.   Next Looper
  90.   Adjust(3) = Int(TotalAscii / Len(password$) / 3)
  91.  
  92.   'Fourth code based on previous three
  93.   Adjust(4) = Adjust(1) + Adjust(2) + Adjust(3)
  94.  
  95.   
  96.   
  97.   'Now check if any Adjust codes are zero
  98.   'If it is zero make it not zero (any number is fine!)
  99.   For Looper = 1 To 4
  100.     If Adjust(Looper) = 0 Then Adjust(Looper) = Looper + Len(password$)
  101.   Next Looper
  102.  
  103.   
  104.   'Now check if any adjusts are the same
  105.   NotYet% = 1
  106.   Do While NotYet%
  107.     NotYet% = 0
  108.     For Loop1 = 1 To 4
  109.       For Loop2 = 1 To 4
  110.         'Don't compare same items
  111.         If Loop1 <> Loop2 Then
  112.           
  113.           'Check for a match
  114.           If Adjust(Loop1) = Adjust(Loop2) Then
  115.             Adjust(Loop2) = Adjust(Loop2) + Len(password$)
  116.             
  117.             'Make sure we didn't make it zero
  118.             If Adjust(Loop2) = 0 Then Adjust(2) = Adjust(Loop2) + Len(password$)
  119.             
  120.             NotYet% = 1
  121.           End If
  122.  
  123.         End If
  124.       Next Loop2
  125.     Next Loop1
  126.   Loop
  127.  
  128.  
  129.   
  130.   
  131.   'Encode or deocde
  132.   Counts = 0: Looper = 0
  133.  
  134.   'Loop until scanned though the whole file
  135.   Do While Looper < Len(strng$)
  136.     
  137.     'Add to Looper
  138.     Looper = Looper + 1
  139.  
  140.     'Keep Adjust code Counts from 1 to 4
  141.     Counts = Counts + 1
  142.     If Counts = 5 Then Counts = 1
  143.     
  144.     'Get the character to change
  145.     ToChange = Asc(Mid$(strng$, Looper, 1))
  146.     
  147.     'ENCODE   Flag%=0
  148.     If Flag% = 0 Then
  149.       
  150.       'If adjustment to high or low then reverse the coding and
  151.       'add in a chr$(255) to mark the change
  152.       If ToChange - Adjust(Counts) < 1 Or ToChange - Adjust(Counts) > 254 Then
  153.         
  154.         Addin$ = Chr$(255) + Chr$(ToChange + Adjust(Counts))
  155.         strng$ = Left$(strng$, Looper - 1) + Addin$ + Mid$(strng$, Looper + 1)
  156.         Looper = Looper + 1
  157.       
  158.       'If adjustment OK then just cahnge the character
  159.       Else
  160.         
  161.         Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  162.  
  163.       End If
  164.  
  165.     'DECODE  Flag% <> 0
  166.     Else
  167.       
  168.       'If find a CHR$(255) then remove it and set Flag255% to
  169.       'ensure reverse codes on next pass reverse coding
  170.       If ToChange = 255 Then
  171.         
  172.         strng$ = Left$(strng$, Looper - 1) + Mid$(strng$, Looper + 1)
  173.         Flag255% = 1
  174.         'Since CHR$(255) was removed we need to back up Looper
  175.         'and Counts because characters all shifted to the left
  176.         Looper = Looper - 1
  177.         Counts = Counts - 1
  178.       
  179.       'If not CHR$(255) then decode watching if Flag255% is set
  180.       Else
  181.         If Flag255% = 1 Then
  182.           Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  183.           Flag255% = 0
  184.         Else
  185.           Mid$(strng$, Looper, 1) = Chr$(ToChange + Adjust(Counts))
  186.         End If
  187.       End If
  188.  
  189.     End If
  190.     
  191.   Loop
  192.  
  193.   
  194.   
  195.   
  196.   'Set function equal to changed string
  197.   If Flag% = 0 Then
  198.     
  199.     'Tack on CHR$(255) to end so it can be recognized as encoded
  200.     KTEncrypt$ = strng$ + String$(5, 255)
  201.  
  202.   Else
  203.     
  204.     KTEncrypt$ = strng$
  205.   
  206.   End If
  207.  
  208.   'Make sure Errors$ is cleared
  209.   Errors$ = ""
  210.  
  211.   Exit Function
  212.  
  213.  
  214.  
  215. ErrorHandler:
  216.   Select Case Err
  217.  
  218.     'Illegal Function Call --> out of range ASCII code
  219.     Case 5
  220.       Errors$ = "INVALID PASSWORD!"
  221.  
  222.     'Is there Password??
  223.     Case 100
  224.       Errors$ = "NO PASSWORD!"
  225.       
  226.     'Is there a strng$ to work with?
  227.     Case 110
  228.       Errors$ = "NO STRING!"
  229.  
  230.     'Encoding a encoded file?
  231.     Case 120
  232.       If UCase$(Errors$) = "FORCE" Then
  233.         Resume Next
  234.       Else
  235.         Errors$ = "FILE ALREADY ENCODED!"
  236.       End If
  237.  
  238.     'Decoding a non-encoded file?
  239.     Case 130
  240.       If UCase$(Errors$) = "FORCE" Then
  241.         Resume Next
  242.       Else
  243.         Errors$ = "FILE NOT ENCODED!"
  244.       End If
  245.     
  246.     'Unanticipated
  247.     Case Else
  248.       Errors$ = Str$(Err)
  249.  
  250.   End Select
  251.   
  252.   KTEncrypt$ = original$
  253.   Exit Function
  254.  
  255. End Function
  256.  
  257.